BBS in a Box 7/BBS in a Box - Macintosh - Volume VII (BBS in a Box) (January 1993).iso/Files/Hyper/N-O/NewSTAK.cpt/NewSTAK/card_3330.txt

Text File | 1989-12-03 | 14KB | 534 lines

-- card: 3330 from stack: in
-- bmap block id: 0
-- flags: 0000
-- background id: 2805
-- name:


-- part contents for background part 9
----- text -----
Here is the complete text of the NewSTAK XCMD, as written for Lightspeed Pascal version 2.03.
-------------------------------------------------------------------------
{NewSTAK creates a new stack with name passed in first parameter.}
{If no first parameter, it uses "New " plus current stack name.}
{If name is not a pathname (with colons) it will use the current folder.}
{Second parameter is the number of the STAK resource to use as the data fork.}
{If no second parameter, it will use the first STAK resource it finds.}
{The entire resource fork of the parent stack is copied to the daughter stack.}
{Operating System and other errors are passed back in "the Result".}

unit Main;

interface
 type
  XCmdPtr = ^XCmdBlock;
  XCmdBlock = record
    paramCount: INTEGER;
    params: array[1..16] of Handle;
    returnValue: Handle;
    passFlag: BOOLEAN;

    entryPoint: ProcPtr;    { to call back to HyperCard }
    request: INTEGER;
    result: INTEGER;
    inArgs: array[1..8] of LongInt;
    outArgs: array[1..4] of LongInt;
   end;

 procedure Main (ParamPtr: XCmdPtr);

implementation

{=================================MAIN}
 procedure NewSTAK (ParamPtr: XCmdPtr);
 FORWARD;

 procedure Main;
 begin
  NewSTAK(ParamPtr);
 end;

 procedure NewSTAK;

  const
   CR = chr(13);
   Unspecified = -32761;{STAK resource to use if not specified by user}

 { request codes for sending commands back to Hypercard}
   xreqSendCardMessage = 1;
   xreqEvalExpr = 2;
   xreqPasToZero = 7;
   xreqZeroToPas = 8;
   xreqStrToNum = 10;
   xreqNumToStr = 14;

  type
   Str19 = string[19];
   Str31 = string[31];

  var
   OldStackPath, OldStackName, NewStackName, NewStackPath: str255;
   STAKResID: longint;
   ReturnString: str255;
   pBlock: HParamBlockRec;
   theParms: HParmBlkPtr;
   AnyErr: OSErr;
   OldResRefNum, NewResRefNum: integer;

{=================================DoJsr}
{ Jump subroutine to a procedure.   Pop address into A0, JSR (A0) }
  procedure DoJsr (addr: ProcPtr);
  inline
   $205F, $4E90;

{=================================SendCardMessage}
{  Send a HyperCard message (a command with arguments) to the current card. }
  procedure SendCardMessage (msg: Str255);

  begin
   with paramPtr^ do
    begin
     inArgs[1] := ORD(@msg);
     request := xreqSendCardMessage;
     DoJsr(entryPoint);
    end;
  end;

{=================================ZeroToPas}
{Fill the Pascal string with the contents of the zero-terminated}
{   string.  You create the Pascal string and pass it in as a VAR }
{   parameter.  Useful for converting the arguments of any XCMD to }
{   Pascal strings.}

  procedure ZeroToPas (zeroStr: Ptr;
     var pasStr: Str255);
  begin
   with paramPtr^ do
    begin
     inArgs[1] := ORD(zeroStr);
     inArgs[2] := ORD(@pasStr);
     request := xreqZeroToPas;
     DoJsr(entryPoint);
    end;
  end;

{=================================PasToZero}
{  Convert a Pascal string to a zero-terminated string.  Returns a handle}
{   to a new zero-terminated string.  The caller must dispose the handle. }

  function PasToZero (str: Str255): Handle;
  begin
   with paramPtr^ do
    begin
     inArgs[1] := ORD(@str);
     request := xreqPasToZero;
     DoJsr(entryPoint);
     PasToZero := Handle(outArgs[1]);
    end;
  end;

{=================================EvalExpr}
{  Evaluate a HyperCard expression and return the answer.  The answer is}
{   a handle to a zero-terminated string, which must be disposed of. }

  function EvalExpr (expr: Str255): Handle;
  begin
   with paramPtr^ do
    begin
     inArgs[1] := ORD(@expr);
     request := xreqEvalExpr;
     DoJsr(entryPoint);
     EvalExpr := Handle(outArgs[1]);
    end;
  end;

{=================================StrToNum}
{  Convert a string of ASCII decimal digits to a signed long integer.}
{   Negative sign is allowed.  }
  function StrToNum (str: Str31): LongInt;
  begin
   with paramPtr^ do
    begin
     inArgs[1] := ORD4(@str);
     request := xreqStrToNum;
     DoJsr(entryPoint);
     StrToNum := outArgs[1];
    end;
  end;

{=================================NumToStr}
{  Convert a signed long integer to a Pascal string.  }
  function NumToStr (num: LongInt): Str31;

   var
    str: Str31;

  begin
   with paramPtr^ do
    begin
     inArgs[1] := num;
     inArgs[2] := ORD(@str);
     request := xreqNumToStr;
     DoJsr(entryPoint);
     NumToStr := str;
    end;
  end;

{=================================CreateNewFile}
{Create a new file (both forks) under the new stack name.}
  function CreateNewFile: boolean;

   var
    theSpecs: FInfo;

  begin
   CreateNewFile := FALSE;

   CreateResFile(NewStackPath);
   AnyErr := ResError;
   if AnyErr <> NoErr then
    begin
     case AnyErr of
     -49, -48:
     ReturnString := Concat('File already exists: ', NewStackPath);
     otherwise
     ReturnString := Concat('Error ', NumToStr(AnyErr), ' trying to create new file name.');
     end;
     EXIT(CreateNewFile);
    end;

{Set the creator and file type.}
   AnyErr := GetFInfo(NewStackPath, 0, theSpecs);
   if AnyErr <> NoErr then
    begin
     ReturnString := Concat('Error ', NumToStr(AnyErr), ' reading new file''s Finder info.');
     EXIT(CreateNewFile);
    end;

   with theSpecs do
    begin
     fdType := 'STAK';
     fdCreator := 'WILD';
    end;
   AnyErr := SetFInfo(NewStackPath, 0, theSpecs);
   if AnyErr <> NoErr then
    begin
     ReturnString := Concat('Error ', NumToStr(AnyErr), ' setting new file Creator and Type.');
     EXIT(CreateNewFile);
    end;

   CreateNewFile := TRUE;
  end;{CreateNewFile}

{=================================ResourceLen}
{Find out how large the resource fork is.}
  function ResourceLen: longint;

   var
    pBlock: ParamBlockRec;
    theParms: ParmBlkPtr;
    OldVolRefNum: integer;

  begin
   AnyErr := GetVRefNum(OldResRefNum, OldVolRefNum);
   if AnyErr <> NoErr then
    begin
     ReturnString := Concat('Error ', NumToStr(AnyErr), ' getting Old VolRefNum.');
     ResourceLen := 0;
     EXIT(ResourceLen);
    end;

   theParms := @pBlock;
   with pBlock do
    begin
     ioCompletion := nil;
     ioNamePtr := @OldStackPath;
     ioVRefNum := OldVolRefNum;
     ioFDirIndex := 0;
    end;

   AnyErr := PBGetFInfo(theParms, FALSE);
   if AnyErr <> NoErr then
    begin
     ReturnString := Concat('Error ', NumToStr(AnyErr), ' reading len of res fork of ', OldStackPath);
     ResourceLen := 0;
    end
   else
    ResourceLen := pBlock.ioFlRLgLen;
  end;{ResourceLen}

{=================================OpenTheDataFile}
  function OpenTheDataFile (FileName: str255;
     VolRefNum: integer;
     var FileRefNum: integer): boolean;
   var
    action: integer;
    mess: string;
    theBlock: HParamBlockRec;
    theName: str255;

  begin
   theName := FileName;
   with theBlock do
    begin
     ioCompletion := nil;
     ioNamePtr := @theName;
     ioVRefNum := VolRefNum;{may be zero if DirID used}
     ioPermssn := fsCurPerm;
     ioMisc := nil;{would be ptr to buffer to use}
     ioDirID := 0;{may be 0 if VRefNum used}
    end;

   AnyErr := PBHOpen(@theBlock, FALSE);
   if AnyErr = NoErr then
    begin
     FileRefNum := theBlock.ioRefNum;
     OpenTheDataFile := TRUE;
    end
   else
    begin
     ReturnString := Concat('Can''t open data fork ', FileName);
     OpenTheDataFile := FALSE;
    end;
  end;{OpenTheDataFile}

{=================================CopyResFork}
  function CopyResFork (ReqBytes: longint): boolean;

   var
    biteBytes, bytesCopied: longint;
    Buffer: ptr;
    HCMark: longint;

  begin
   CopyResFork := FALSE;

{Set up a buffer of no more than 32K.}
   if ReqBytes > 32000 then
    biteBytes := 32000
   else
    biteBytes := ReqBytes;
   Buffer := NewPtr(biteBytes);
   if Buffer = nil then
    begin
     ReturnString := Concat('Can''t allocate pointer of length ', NumToStr(biteBytes));
     EXIT(CopyResFork);
    end;

{Look up the current file Mark so we can restore it when we're done.}
   AnyErr := GetFPos(OldResRefNum, HCMark);
   if AnyErr <> NoErr then
    begin
     ReturnString := Concat('Can''t get HC''s File Pos Mark.');
     EXIT(CopyResFork);
    end;

{Set the current file Mark to 0.}
   AnyErr := SetFPos(OldResRefNum, fsFromStart, 0);
   if AnyErr <> NoErr then
    begin
     ReturnString := Concat('Can''t set File Pos Mark to start of stack.');
     EXIT(CopyResFork);
    end;

{Now read the resource fork in chunks no larger than 32K.}
   bytesCopied := 0;
   repeat
    biteBytes := ReqBytes - bytesCopied;
    if biteBytes > 32000 then
     biteBytes := 32000;
    AnyErr := FSRead(OldResRefNum, biteBytes, Buffer);
    if AnyErr <> NoErr then
     begin
     ReturnString := Concat('Error ', NumToStr(AnyErr), ' reading ', NumToStr(biteBytes), ' of ', NumToStr(ReqBytes), ' bytes from ', OldStackPath);
     AnyErr := FSClose(OldResRefNum);
     DisposPtr(Buffer);
     EXIT(CopyResFork);
     end;

{Write the buffer to the new fork.}
    AnyErr := FSWrite(NewResRefNum, biteBytes, Buffer);
    if AnyErr <> NoErr then
     begin
     case AnyErr of
     DskFulErr:
     ReturnString := 'This volume is full.';
     fLckdErr, wPrErr, vLckdErr, wrPermErr:
     ReturnString := 'This volume is locked.';
     otherwise
     ReturnString := Concat('Error ', NumToStr(AnyErr), ' writing ', NewStackPath);
     end;

     DisposPtr(Buffer);
     EXIT(CopyResFork);
     end;

    bytesCopied := bytesCopied + biteBytes;
   until bytesCopied >= ReqBytes;
   DisposPtr(Buffer);

{Set the current file Mark to what it was before we mucked with it.}
   AnyErr := SetFPos(OldResRefNum, fsFromStart, HCMark);
   if AnyErr <> NoErr then
    begin
     ReturnString := Concat('Can''t restore File Pos Mark.');
     EXIT(CopyResFork);
    end;

   CopyResFork := TRUE;
  end;{CopyResFork}

{=================================CopyEverything}
  procedure CopyEverything;

   var
    NewDataRefNum: integer;
    resCopyOK: boolean;
    HandSize: longint;
    STAKResHand: handle;
    ResourceForkLength: longint;

  begin
{First try to find the chosen STAK resource. If not found, don't bother with resource fork.}
   if STAKResID = Unspecified then
    begin
     STAKResHand := GetIndResource('STAK', 1);{look at first resource of this type}
     if STAKResHand = nil then
     begin
     ReturnString := 'STAK resource not found or unsufficient RAM.';
     EXIT(CopyEverything);
     end;
    end
   else
    begin
     STAKResHand := GetResource('STAK', STAKResID);
     if STAKResHand = nil then
     begin
     ReturnString := Concat('STAK ', NumToStr(STAKResID), ' not found or insufficient RAM.');
     EXIT(CopyEverything);
     end;
     if ResError <> NoErr then
     begin
     ReturnString := Concat('Resource Error ', NumToStr(ResError), ' reading STAK resource.');
     EXIT(CopyEverything);
     end;
    end;

{Look up length of resource fork now.}
   ResourceForkLength := ResourceLen;

{Open data fork of new stack.}
   DetachResource(STAKResHand);{hide it from Resource Manager}
   if not OpenTheDataFile(NewStackPath, 0, NewDataRefNum) then
    begin
     DisposHandle(STAKResHand);
     EXIT(CopyEverything);
    end;

{Make copy of STAK resource in data fork of new stack.}
   HandSize := GetHandleSize(STAKResHand);
   AnyErr := FSWrite(NewDataRefNum, HandSize, STAKResHand^);
   if AnyErr <> NoErr then
    case AnyErr of
     DskFulErr:
     ReturnString := 'This volume is full.';
     fLckdErr, wPrErr, vLckdErr, wrPermErr:
     ReturnString := 'This volume is locked.';
     otherwise
     ReturnString := Concat('Error ', NumToStr(ResError), ' writing ', NewStackPath);
    end;

{Always close the file and flush the volume.}
   DisposHandle(STAKResHand);
   AnyErr := FSClose(NewDataRefNum);
   AnyErr := FlushVol(nil, NewDataRefNum);
   if ReturnString <> '' then
    EXIT(CopyEverything);

{And open the copy's resource fork.}
   AnyErr := OpenRF(NewStackPath, 0, NewResRefNum);
   if AnyErr <> NoErr then
    begin
     ReturnString := Concat('Can''t open ', NewStackPath);
     EXIT(CopyEverything);
    end;

{Copy the resource fork.}
   resCopyOK := CopyResFork(ResourceForkLength);

{Close the new resource fork, no matter how bad things may look.}
   AnyErr := FSClose(NewResRefNum);
  end;{CopyEverything}

{=================================MAIN}

  var
   str: str255;
   c, FileNameLen: integer;
   tempHand: handle;

 begin
  ReturnString := '';

{Look up RefNum of current open stack by asking for current resource file.}
{This assumes that the "From" stack has resources. Since we ARE a resource, it must.}
  OldResRefNum := CurResFile;

{Ask HyperCard the name of the source stack.}
  tempHand := EvalExpr('the long name of this stack');
  ZeroToPas(tempHand^, OldStackPath);
  delete(OldStackPath, 1, 7);{chop off 'stack "'}
  delete(OldStackPath, length(OldStackPath), 1);{chop off final '"'}
  DisposHandle(tempHand);
  for c := length(OldStackPath) downto 1 do
   if OldStackPath[c] = ':' then
    LEAVE;
  OldStackName := copy(OldStackPath, c + 1, 31);

{Try to read first parameter.}
  NewStackName := '';
  NewStackPath := '';
  if ParamPtr^.paramCount > 0 then
   ZeroToPas(ParamPtr^.params[1]^, NewStackPath);

{If volume and folder not specified, use path to current stack.}
  if pos(':', NewStackPath) <= 0 then
   begin
    NewStackName := NewStackPath;
    NewStackPath := OldStackPath;
   end;

{If even file name not specified, use "New " plus current stack name.}
  if NewStackName = '' then
   begin
    for c := length(NewStackPath) downto 1 do
     if NewStackPath[c] = ':' then
     LEAVE;
    NewStackName := Concat('New ', copy(NewStackPath, c + 1, 27));
   end;

{Build full pathname.}
  for c := length(NewStackPath) downto 1 do
   if NewStackPath[c] = ':' then
    LEAVE;
  delete(NewStackPath, c + 1, 100);
  NewStackPath := Concat(NewStackPath, NewStackName);

{If there's a second parameter, use it as number of the STAK resource to copy.}
  STAKResID := Unspecified;{Hope they don't really choose this one!}
  if ParamPtr^.paramCount > 1 then
   begin
    ZeroToPas(ParamPtr^.params[2]^, str);
    STAKResID := StrToNum(str);
   end;

{Create a new file (both forks) under the new stack name, and copy everything.}
  if CreateNewFile then
   CopyEverything;

{Return the result.}
  paramPtr^.returnValue := PasToZero(ReturnString);
 end;{end NewSTAK}

{=================================end of unit}
end.